This article is about Language Translation in MS Access.

We can perform language translation from default language English to any other language.We have included forty four international languages.In order to implement these concept basic controls have been created first using MS Access form. Example has been shown in figure 1.1

As shown in above figure we have created four different controls two text boxes and one combo box and a single button.From combo box user can select a particular language at a time and after that typing intended sentence or word in left text box .To perform translation into selected language click on Translate.The moment we click on Button Translate subsequently translated version will be shown in right text box.

Now create a table with three different fields Lang_id, language , lang_Code as shown in Fig 1.2

Here we will make forty four entries into the table as we are going to implement language translation for forty four international languages.And source language or default language will be English.

Next twenty four entries have been shown in figure 1.3

To perform language translation feature in MS Access we will use Microsoft Language Translator service. Translation services are provided by Microsoft Translator 2.0 via Azure. As of 6/2014 this service is free up to 2,000,000 characters per month. You will need a Client ID and Client Secret and these values need to be replacing with ClientID and ClientSecret constants used in VBA code.For step by step instruction click the link mention below:

After going through Steps mention above next is coding section where we will integrate Microsoft Translator service with our MS Access Application. Before we process with coding make it sure you have set reference to Microsoft XML, v3.0. Figure 1.4 is shown below to implement this step.

In order to use Microsoft translator Service make it sure reference to Microsoft XML v3.0 or above has been set. As shown in figure 1.4 click on Tool and then References and select check box Microsoft XML v3.0.

Coding:-

To implement coding section set the on click event for Translate button and add mention below code in it. cmdtrl is name of Translate Button.

Private Sub cmdtrl_Click()
DoCmd.Hourglass True
Me.txtdest = MicrosoftTranslate(Me.txtsrc, "en", Me.Combo16.Column(1))
DoCmd.Hourglass False
End Sub

Now create two different modules first is named mdlmaininvoked and second one is named mdlbeinginvoked. As shown in above code main functionality implemented by function MicrosoftTranslate.

Me.txtdest = MicrosoftTranslate(Me.txtsrc, "en", Me.Combo16.Column(1)

This function takes three different parameters first is "Me.txtsrc" is sentence or word needs to be translated and it is captured from left text box,second is "en" is source language and last is language code to which we translating and it is captured from selected language from combo box.Function MicrosoftTranslate returns String value that is stored into txtdest text box (right hand side textbox See Fig 1.1).Rest of the code for two different modules is shown below.

Module name:- mdlmaininvoked

This module contains code shown below.

Const CLIENT_ID As String = "YOUR_CLIENT_ID"
Const CLIENT_SECRET As String = "YOUR_CLIENT_SECRET"
Public Const cstrMSTranslator As String = "http://api.microsofttranslator.com/V2/Http.svc/"
Public Function MicrosoftTranslate(txtsrc As String, Optional sLanguageFrom As String = "en", Optional sLanguageTo As String = " ") As String

Dim sRequest As String, sResponseText As String
sRequest = "Translate?from=" & sLanguageFrom & "&to=" & sLanguageTo & "&text=" & UTF8_Encode(txtsrc)
sResponseText = MSHttpRequest(sRequest)
MicrosoftTranslate = StringFromXML(sResponseText)
End Function

Public Function MicrosoftTranslatorDetect(txtsrc As String) As String
' returns lowercase two character code for language type eg "en"
MicrosoftTranslatorDetect = StringFromXML (MSHttpRequest("Detect?text=" & txtsrc)) End Function

' authentication using token
Public Function MSHttpRequest(sRequest As String) As String
Dim sURL As String
Dim oH As MSXML2.XMLHTTP
Dim sToken As String
sURL = cstrMSTranslator & sRequest
sToken = GetAccessToken()
Set oH = CreateObject("MSXML2.XMLHTTP")
oH.Open "GET", sURL, False
oH.setRequestHeader "Authorization", "Bearer " & sToken
oH.send
MSHttpRequest = oH.responseText
Set oH = Nothing
End Function

Public Function GetAccessToken() As String
Static sAccess_Token As String, dtExpiry_Time As Date
Const OAUTH_URI As String = "http://datamarket.accesscontrol .windows.net/v2/OAuth2-13"
Dim sRequest As String, sResponse As String
Dim webRequest As MSXML2.XMLHTTP
Dim varTest As Variant
If Now() > dtExpiry_Time Then 'time for a new access token
Set webRequest = CreateObject("MSXML2.XMLHTTP")
sRequest = "grant_type=client_credentials" & _
"&client_id=" & URLEncode(CLIENT_ID) & _
"&client_secret=" & URLEncode(CLIENT_SECRET) & _
"&scope= http://api.microsofttranslator.com"
' "GET" gets {"error":"invalid_request", "error_description":"ACS90007: Request method not allowed. ...
webRequest.Open "POST", OAUTH_URI, False

webRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
webRequest.send sRequest
sResponse = webRequest.responseText
Set webRequest = Nothing
'{"error":"invalid_client", "error_description":"ACS50012:Authentication failed.\r\nTrace ID: 0a050673-ccfc-469a-9797-b27a49bfb 4e6\r\nTimestamp: 2012-07-26 07:32:03Z"}

If InStr(1, sResponse, """error:""", vbTextCompare) > 0 Then
Err.Raise 9999, "GetAccessToken " & sResponse
End If
sAccess_Token = NameValue("access_token", sResponse)
dtExpiry_Time = Now() + Val(NameValue("expires_in", sResponse)) / 60 / 60 / 24 ' maybe *.95 for safety margin

'Debug.Print "Token expires at "; Format$(dtExpiry_Time, "hh:mm:ss")
End If
GetAccessToken = sAccess_Token
End Function

'returns what is inside pt
Private Function StringFromXML(txtsrc As String) As String
Dim lPosGT As Long
lPosGT = InStr(1, txtsrc, ">")
StringFromXML = Mid$(txtsrc, lPosGT + 1, InStr(lPosGT, txtsrc, "<") - lPosGT - 1)
End Function
Private Function NameValue(ByVal sName As String, ByVal sResponse As String) As String ' return value part of "name":"value" wit hout quotes from full response string

Dim lPosStart As Long, lPosEnd As Long
Const DQ = """"
lPosStart = InStr(1, sResponse, DQ & sName & DQ & ":") ' "name":
If lPosStart > 0 Then
lPosStart = lPosStart + Len(sName) + 4
lPosEnd = InStr(lPosStart, sResponse, DQ)
NameValue = Mid$(sResponse, lPosStart, lPosEnd - lPosStart)
End If
End Function

Private Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
Dim StringLen As Long
StringLen = Len(StringVal)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String
If SpaceAsPlus Then Space = "+" Else Space = "%20"
For i = 1 To StringLen
Char = Mid$(StringVal, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = Space
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function

Module name:- mdlbeinginvoked

This module contains code shown below.

Public Function UTF8_Encode(ByVal strIn As String) As String
Dim lngPos As Long
Dim lngUSV As Long
Dim strUTF8 As String
strIn = Trim(strIn)
For lngPos = 1 To Len(strIn)
lngUSV = MakeUSV(Mid$(strIn, lngPos, 2))
If lngUSV < &H10 And lngUSV <> &HA And lngUSV <> &H9 Then
'Single digit code points. Need to add 0 after %.
'IMPORTANT NOTE: Also stripping LF and Tab
If lngUSV <> &HD Then 'CR
strUTF8 = strUTF8 & "%0" & Hex(AscW(Mid$(strIn, lngPos, 1)))
Else
strUTF8 = strUTF8 & "%20" 'Replace CR with space.
End If
ElseIf lngUSV > &H1F And lngUSV < &H80 Then
'me-ASCII - Basic Latin
strUTF8 = strUTF8 & "%" & Hex(AscW(Mid$(strIn, lngPos, 1)))
ElseIf lngUSV > &H7F And lngUSV < &H800 Then
'Basic Multilingual Plane
strUTF8 = strUTF8 & "%" & Hex((lngUSV \ &H40) Or &HC0)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)
ElseIf lngUSV > &H7FF And lngUSV < &H10000 Then
'Basic Multilingual Plane

strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H1000) And &HF) Or &HE0)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)
ElseIf lngUSV > &HFFFF& And lngUSV < &H2A700 Then

'Surrogate pairs - Supplementary Multilingual Plane.
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40000) And &H7) Or &HF0)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H1000&) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)

End If
If IsHighSurrogate(AscW(Mid$(strIn, lngPos, 1))) Then
lngPos = lngPos + 1
End If
Next
UTF8_Encode = strUTF8
End Function

Public Function MakeUSV(strCharacter As String) As Long
' Makes Unicode USV value for one character.
' USV is returned as a decimal value and as a Long.
' Handles surrogate pairs.

Dim lngHiSurr As Long 'Value of high surrogate.
Dim lngLowSurr As Long 'Value of low surrogate.

'Testing for length of 1 or 2 character. If a single character is represented
'by a surrogate pair Len() will report it's length as 2.
If LenB(strCharacter & vbNullString) <> 0 And Len(strCharacter) <= 2 Then
If IsSurrogatePair(strCharacter) Then
lngLowSurr = CLng("&H" & Hex$(AscW(Mid$(strCharacter, 2, 1))))
lngHiSurr = CLng("&H" & Hex$(AscW(Left$(strCharacter, 1))))
'From "The Unicode Standard, Version 6.0", Chapter 3, Section 7 "Surrogates".
MakeUSV = (lngHiSurr - CLng("&HD800")) * CLng("&H400") + _
(lngLowSurr - CLng("&HDC00")) + CLng("&H10000")
Else
MakeUSV = CLng("&H" & Hex$(AscW(strCharacter)))
End If
End If
End Function

Private Function IsSurrogatePair(txtCharacter As String) As Boolean
' Tests if a character is represented by a Unicode surrogate pair.
' Takes a single Unicode character as argument and returnes true or false.
Dim lngHiSurr As Long

' NOTE: Len returns 2 for a single character if it is a surrogate pair.
If LenB(txtCharacter & vbNullString) <> 0 And Len(txtCharacter) <= 2 Then
lngHiSurr = CLng("&H" & Hex$(AscW(Mid$(txtCharacter, 1, 1))))
If Len(txtCharacter) = 2 Then
If lngHiSurr >= &HD800& And lngHiSurr <= &HDBFF& Then
IsSurrogatePair = True
Else
IsSurrogatePair = False
End If
Else
IsSurrogatePair = False
End If
End If
End Function

Public Function IsHighSurrogate(intCodePoint As Integer) As Boolean
'Returns true if code point is a Unicode high surrogate.

Const cintHighSurrLB As Integer = &HD800 'Lower bound
Const cintHighSurrUB As Integer = &HDBFF 'Upper bound

If intCodePoint >= cintHighSurrLB And intCodePoint <= cintHighSurrUB Then
IsHighSurrogate = True
Else
IsHighSurrogate = False
End If
End Function